home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / oobr / br-eif-ft.el < prev    next >
Encoding:
Text File  |  1995-05-13  |  17.2 KB  |  508 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         br-eif-ft.el
  4. ;; SUMMARY:      Eiffel OO-Browser class and feature functions.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     oop, tools
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola Inc.
  10. ;;
  11. ;; ORIG-DATE:    03-Oct-90
  12. ;; LAST-MOD:     11-May-95 at 11:24:33 by Bob Weiner
  13. ;;
  14. ;; Copyright (C) 1990-1995  Free Software Foundation, Inc.
  15. ;; See the file BR-COPY for license information.
  16. ;;
  17. ;; This file is part of the OO-Browser.
  18. ;;
  19. ;; DESCRIPTION:  
  20. ;; DESCRIP-END.
  21.  
  22. ;; ************************************************************************
  23. ;; Other required Elisp libraries
  24. ;; ************************************************************************
  25.  
  26. (require 'eif-calls)
  27.  
  28. ;; ************************************************************************
  29. ;; Public variables
  30. ;; ************************************************************************
  31.  
  32. (defconst eif-type-tag-separator ","
  33.   "String that separates a tags type from its normalized definition form.")
  34.  
  35. ;; ************************************************************************
  36. ;; Public functions
  37. ;; ************************************************************************
  38.  
  39. (defun eif-feature-implementors (ftr-name)
  40.   "Return unsorted list of Eiffel feature tags which implement FTR-NAME."
  41.   (eif-feature-matches (concat "^" (regexp-quote ftr-name) "$")))
  42.  
  43. (defun eif-feature-name-to-regexp (name)
  44.   "Converts feature NAME into a regular expression matching the feature's name tag."
  45.   (if (string-match (concat "^" br-feature-type-regexp " ") name)
  46.       (setq name (substring name (match-end 0))))
  47.   (format "%s%s%s %s[ \n]"
  48.       eif-identifier eif-type-tag-separator br-feature-type-regexp
  49.       (regexp-quote name)))
  50.  
  51. (fset 'eif-feature-signature-to-name 'eif-feature-partial-name)
  52.  
  53. (defun eif-feature-signature-to-regexp (signature)
  54.   "Given an Eiffel class or feature SIGNATURE, return regexp to match its definition."
  55.   (let ((regexp) class name type)
  56.     (setq regexp
  57.       (cond ((string-match (concat eif-type-tag-separator
  58.                        "\\(" br-feature-type-regexp "\\) ")
  59.                    signature)
  60.          (setq name (substring signature (match-end 0))
  61.                type (string-to-char
  62.                  (substring
  63.                   signature (match-beginning 1) (match-end 1))))
  64.          (cond ((memq type '(?- ?1 ?>))
  65.             ;; routine
  66.             (eif-routine-to-regexp name))
  67.                ((= type ?=)
  68.             ;; attribute
  69.             (eif-attribute-to-regexp name))))
  70.         ((equal 0 (string-match eif-identifier signature))
  71.          ;; Assume is a class name
  72.          (concat eif-class-name-before (regexp-quote signature)
  73.              eif-class-name-after))))
  74.     (or regexp
  75.     (error "(eif-feature-signature-to-regexp): Invalid format, '%s'"
  76.            signature))))
  77.  
  78. (defun eif-feature-tree-command-p (class-or-signature)
  79.   "Display definition of CLASS-OR-SIGNATURE if a signature and return t, else return nil."
  80.   (if (br-in-browser) (br-to-view-window))
  81.   (br-feature-found-p (br-feature-file class-or-signature)
  82.               class-or-signature))
  83.  
  84. (defun eif-list-features (class &optional indent)
  85.   "Return sorted list of Eiffel feature names lexically defined in CLASS."
  86.   (let ((class-tag (concat "\n" class eif-type-tag-separator))
  87.     (features) start end)
  88.     (save-excursion
  89.       (set-buffer
  90.        (funcall br-find-file-noselect-function br-feature-tags-file))
  91.       (goto-char 1)
  92.       (if (not (search-forward class-tag nil t))
  93.       nil
  94.     (setq start (match-beginning 0)
  95.           end (if (search-forward "\^L\n" nil t)
  96.               (match-beginning 0)
  97.             (point-max)))
  98.     (goto-char start)
  99.     ;; Feature defs can occur only within a single file.
  100.     (while (search-forward class-tag end t)
  101.       (setq features (cons (br-feature-current) features)))
  102.     (eif-sort-features features)))))
  103.  
  104. (defun eif-get-feature-tags (feature-file feature-list)
  105.   "Save Eiffel feature tags defined in FEATURE-FILE to 'br-feature-tags-file'.
  106. Assume FEATURE-FILE has already been read into a buffer and that
  107. 'br-feature-tags-init' has been called.  FEATURE-LIST is the list
  108. of tags to save."
  109.   (interactive)
  110.   (let ((obuf (current-buffer)))
  111.     (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
  112.     (goto-char 1)
  113.     ;; Delete any prior feature tags associated with feature-file
  114.     (if (search-forward feature-file nil 'end)
  115.     (progn (forward-line -1)
  116.            (let ((start (point)))
  117.          (search-forward "\^L" nil 'end 2)
  118.          (backward-char 1)
  119.          (delete-region start (point))
  120.          )))
  121.     (if feature-list
  122.     (progn (insert "\^L\n" feature-file "\n")
  123.            (mapcar (function (lambda (tag) (insert tag "\n")))
  124.                feature-list)))
  125.     (set-buffer obuf)))
  126.  
  127. (defun eif-scan-features-in-class (class start end)
  128.   "Return unordered list of Eiffel feature definitions in CLASS.
  129. START and END give buffer region to search."
  130.   (save-excursion
  131.     (save-restriction
  132.       (narrow-to-region start end)
  133.       (goto-char start)
  134.       (let ((attributes-and-routines (eif-parse-features t)))
  135.     (append
  136.      (mapcar
  137.       (function (lambda (routine)
  138.               (concat class eif-type-tag-separator routine)))
  139.       (cdr attributes-and-routines))
  140.      (mapcar
  141.       (function (lambda (attribute)
  142.               (concat class eif-type-tag-separator attribute)))
  143.       (car attributes-and-routines)))))))
  144.  
  145. (defun eif-sort-features (feature-list)
  146.   (sort feature-list 'eif-feature-lessp))
  147.  
  148. (defun eif-to-definition (&optional identifier)
  149.   "If point is within an Eiffel class or feature name, try to move to its definition.
  150. With optional IDENTIFIER, do the same instead for it."
  151.   (interactive)
  152.   (let ((cl (or identifier (eif-find-class-name))))
  153.     (cond
  154.      ((eif-keyword-p) nil)
  155.      ((br-check-for-class cl))
  156.      ((eif-feature cl))
  157.      ((progn
  158.     (beep)
  159.     (message
  160.      "(OO-Browser):  Select an Eiffel identifier to move to its definition.")
  161.     nil))
  162.      )))
  163.  
  164. ;; ************************************************************************
  165. ;; Private functions
  166. ;; ************************************************************************
  167.  
  168. (defun eif-export-feature-p ()
  169.   "Return nil unless point is within a class export clause."
  170.   (save-excursion
  171.     (let ((end (point)))
  172.       (beginning-of-line)
  173.       ;; If in a comment, return nil.
  174.       (if (search-forward "--" end t)
  175.       nil
  176.     (goto-char (point-min))
  177.     (and (re-search-forward eif-export-key-regexp end t)
  178.          (not (re-search-forward "^\\(inherit\\|feature\\)\\([ \t]\\|$\\)" end t)))))))
  179.  
  180. (defun eif-feature (&optional ftr)
  181.   "Return nil if definition is not found for optional FTR or feature declared at point."
  182.   (interactive)
  183.   (let ((class-deferred)
  184.     (class)
  185.     (deferred-p)
  186.     (ftr-def-class))
  187.     (cond ((or ftr (and (eif-export-feature-p)
  188.             (setq ftr (eif-to-feature-decl))))
  189.        (if (and (setq class-deferred (eif-get-class-name-from-source))
  190.             (setq class (car class-deferred)
  191.               deferred-p (cdr class-deferred)
  192.               ftr-def-class (eif-find-ancestors-feature
  193.                      (list class) deferred-p ftr)))
  194.            (cond ((equal (car ftr-def-class) class) t)
  195.              ((equal (cdr ftr-def-class) ftr)
  196.               ;; Feature inherited but not renamed.
  197.               (message
  198.                "Feature '%s' of class '%s' inherited from class '%s'."
  199.                ftr class (car ftr-def-class)))
  200.              ;; Feature inherited and renamed.
  201.              (t (message "Feature '%s', class '%s' from feature '%s', class '%s'."
  202.                  ftr class (cdr ftr-def-class)
  203.                  (car ftr-def-class))
  204.             t))
  205.          (beep)
  206.          (message "(OO-Browser):  '%s' feature not found." ftr)
  207.          t))
  208.       ((and (not ftr) (eif-feature-def-p)))
  209.       ;;
  210.       ;; Later we might add the case of a feature invocation here.
  211.       ;;
  212.       )))
  213.  
  214. (defun eif-feature-def-p ()
  215.   "If point is within a feature definition's name, display feature including leading comments."
  216.   (let ((opoint (point)))
  217.     (beginning-of-line)
  218.     (if (or (looking-at eif-routine-regexp)
  219.         (looking-at eif-attribute-regexp))
  220.     (progn (setq opoint (match-beginning eif-feature-name-grpn))
  221.            (eif-to-comments-begin)
  222.            (recenter 0)
  223.            (goto-char opoint)
  224.            t)
  225.       (goto-char opoint)
  226.       nil)))
  227.  
  228. (defun eif-feature-matches (regexp)
  229.   "Return an unsorted list of feature tags whose names match in part or whole to REGEXP."
  230.   ;; Ensure match to feature names only; also handle "^" and "$" meta-chars
  231.   (setq regexp
  232.     (concat "^\\(" eif-identifier "\\)"
  233.         eif-type-tag-separator
  234.         br-feature-type-regexp " "
  235.         (if (equal (substring regexp 0 1) "^")
  236.             (progn (setq regexp (substring regexp 1)) nil)
  237.           (concat "[" eif-identifier-chars "]*"))
  238.         (if (equal (substring regexp -1) "$")
  239.             (substring regexp 0 -1)
  240.           (concat regexp "[" eif-identifier-chars "]*"))
  241.         "[ \t\n\r]"))
  242.   (save-excursion
  243.     (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
  244.     (goto-char 1)
  245.     (let ((features) start end)
  246.       (if (not (re-search-forward regexp nil t))
  247.       nil
  248.     (setq start (match-beginning 0)
  249.           end (if (search-forward "\^L\n" nil t)
  250.               (match-beginning 0)
  251.             (point-max)))
  252.     (goto-char start)
  253.     ;; Feature defs can occur only within a single file.
  254.     (while (re-search-forward regexp end t)
  255.       (backward-char) ;; Might have moved past newline.
  256.       (setq features (cons (br-feature-current) features))))
  257.       features)))
  258.  
  259. (defun eif-feature-lessp (feature1 feature2)
  260.   (string-lessp (eif-feature-partial-name feature1)
  261.         (eif-feature-partial-name feature2)))
  262.  
  263. (defun eif-feature-partial-name (signature &optional with-class for-display)
  264.   "Extract the feature name without its class name from feature SIGNATURE.
  265. If optional WITH-CLASS is non-nil, class name and 'eif-type-tag-separator'
  266. are prepended to the name returned.  If optional FOR-DISPLAY is non-nil, a
  267. feature type character is prepended to the name for display in a browser
  268. listing."
  269.   (if (string-match (concat eif-type-tag-separator
  270.                 "\\(" br-feature-type-regexp " \\)")
  271.             signature)
  272.       (let ((class (substring signature 0 (match-beginning 0)))
  273.         (name (substring signature (match-end 0))))
  274.     (cond ((and with-class for-display)
  275.            signature)
  276.           (with-class
  277.            (concat class eif-type-tag-separator name))
  278.           (for-display
  279.            (substring signature (match-beginning 1)))
  280.           (t name)))
  281.     signature))
  282.  
  283. (defun eif-feature-tag-class (element-tag)
  284.   "Extract the class name from ELEMENT-TAG."
  285.   (if (string-match eif-type-tag-separator element-tag)
  286.       (substring element-tag 0 (match-beginning 0))
  287.     ""))
  288.  
  289. (defun eif-find-ancestors-feature (class-list deferred-class ftr)
  290.   (let* ((classes class-list)
  291.      (cl)
  292.      (file)
  293.      (found-ftr))
  294.     (if (null class-list)
  295.     nil
  296.       (while (and (not found-ftr) classes)
  297.     (setq cl (car classes)
  298.           file (br-class-path cl))
  299.     (and file (setq found-ftr
  300.             (br-feature-found-p file ftr deferred-class)))
  301.     ;; If found-ftr is a cons cell, then only one parent class need
  302.     ;; be searched to look for ftr.
  303.     (if (consp found-ftr)
  304.         (setq class-list (list (car found-ftr))
  305.           ftr (cdr found-ftr)))
  306.     (setq classes (cdr classes)))
  307.       (cond ((consp found-ftr)
  308.          (eif-find-ancestors-feature class-list deferred-class ftr))
  309.         ((null found-ftr)
  310.          (eif-find-ancestors-feature 
  311.           (apply 'append (mapcar (function
  312.                        (lambda (cl) (br-get-parents cl)))
  313.                      class-list))
  314.           deferred-class
  315.           ftr))
  316.         (t (cons cl ftr))))))
  317.  
  318. ;; Prefixed with 'eiffel' rather than 'eif' since works as a standalone
  319. ;; feature in buffers whose major mode is 'eiffel-mode'.  It is used by the
  320. ;; browser but may also be used standalone.
  321. ;;
  322. (defun eiffel-find-feature (feature-name)
  323.   "Move point to start of feature named FEATURE-NAME in current buffer.
  324. Display feature including all preceding comments at the top of the window.
  325. Move point and return non-nil iff FEATURE-NAME is found."
  326.   (interactive "sFeature to find: ")
  327.   (cond ((eif-locate-feature
  328.       feature-name (eif-routine-to-regexp feature-name)))
  329.     ((eif-to-attribute feature-name)
  330.      (let ((opoint (point)))
  331.        (eif-to-comments-begin)
  332.        (recenter 0)
  333.        (goto-char opoint)
  334.        (back-to-indentation)
  335.        t))))
  336.  
  337. (defun eif-find-class-name ()
  338.   "Return class name that point is within, else nil."
  339.   (if (= (point) (point-max)) (skip-chars-backward " \t\n"))
  340.   (save-excursion
  341.     (skip-chars-forward " \t")
  342.     (skip-chars-backward eif-identifier-chars)
  343.     (skip-chars-backward " \t\n")
  344.     (backward-char 1)
  345.     (and (looking-at eif-class-name-pat)
  346.      (eif-set-case
  347.       (buffer-substring (match-beginning 2)
  348.                 (match-end 2))))))
  349.  
  350. (defun eif-find-feature (feature-name)
  351.   "With point selecting a class in a listing buffer, move point to definition of FEATURE-NAME in viewer window.
  352. Move point and return non-nil iff FEATURE-NAME is found."
  353.   (interactive "sFeature to find: ")
  354.   ;; If selected class is displayed, don't go to start of class
  355.   (if (equal (br-class-path (br-find-class-name))
  356.          (progn
  357.            (br-to-from-viewer)
  358.            (expand-file-name buffer-file-name)))
  359.       nil
  360.     (br-edit))
  361.   (if (eiffel-find-feature feature-name)
  362.       (progn (recenter 0)
  363.          t)
  364.     (br-to-from-viewer)
  365.     (and (interactive-p)
  366.      (progn
  367.        (beep)
  368.        (message "(OO-Browser):  No '%s' feature found." feature-name)))))
  369.  
  370. (defun eif-feature-locate-p (feature-tag)
  371.   (let (start class)
  372.     (if (string-match (concat "\\`[^\]\[]+" eif-type-tag-separator)
  373.               feature-tag)
  374.     ;; First move to the proper class implementation, so that if two
  375.     ;; classes in the same file have the same feature signature, we still
  376.     ;; end up at the right one.
  377.     (progn
  378.       (setq class (substring feature-tag 0 (1- (match-end 0))))
  379.       (re-search-forward
  380.        (concat eif-class-name-before (regexp-quote class)
  381.            eif-class-name-after)
  382.        nil t)))
  383.     (if (not (re-search-forward
  384.           (eif-feature-signature-to-regexp feature-tag) nil t))
  385.     nil
  386.       (setq start (match-beginning 0))
  387.       (goto-char start)
  388.       (skip-chars-forward " \t\n")
  389.       (eif-to-comments-begin)
  390.       (recenter 0)
  391.       (goto-char start)
  392.       t)))
  393.  
  394. (defun eif-keyword-p ()
  395.   "Return t if point is within an Eiffel keyword, else nil."
  396.   (if (= (point) (point-max)) (skip-chars-backward " \t\n"))
  397.   (save-excursion
  398.     (skip-chars-forward " \t")
  399.     (skip-chars-backward eif-identifier-chars)
  400.     (and (looking-at eif-identifier)
  401.      (br-member-sorted-strings (buffer-substring (match-beginning 0)
  402.                              (match-end 0))
  403.                    eif-reserved-words))))
  404.  
  405. (defun eif-locate-feature (ftr ftr-pat)
  406.   (let ((opoint (point)))
  407.     (goto-char (point-min))
  408.     (if (and (re-search-forward "^feature\\([ \t]\\|$\\)" nil t)
  409.          (re-search-forward ftr-pat nil t))
  410.     (progn (goto-char (match-beginning eif-feature-name-grpn))
  411.            (setq opoint (point))
  412.            (eif-to-comments-begin)
  413.            (recenter 0)
  414.            (goto-char opoint)
  415.            t)
  416.       (goto-char opoint)
  417.       (and (interactive-p) (error (format "Feature '%s' not found."
  418.                       ftr))))))
  419.  
  420. (defun eif-renamed-feature-p (ftr)
  421.   (goto-char (point-min))
  422.   (let ((rename-regexp "[ \t\n]+rename[ \t\n]")
  423.     (rename-match
  424.      (concat eif-identifier "[ \t\n]+as[ \t\n]+" ftr "[,; \t\n]"))
  425.     (prev-feature-nm)
  426.     (prev-class)
  427.     (parents))
  428.     (while (and (setq prev-feature-nm
  429.               (and (re-search-forward rename-regexp nil t)
  430.                (re-search-forward rename-match nil t)))
  431.         (setq prev-feature-nm
  432.               (buffer-substring (match-beginning 1) (match-end 1))
  433.               prev-class (match-beginning 0))
  434.         (progn (backward-char 1)
  435.                (eif-in-comment-p))))
  436.     (if prev-feature-nm
  437.     (progn (goto-char prev-class)
  438.            (setq parents (eif-get-parents-from-source buffer-file-name))
  439.            (if (re-search-backward (concat
  440.                     "[^[][ \t\n]+\\("
  441.                     (mapconcat
  442.                       (function (lambda (cl)
  443.                               (eif-set-case-type cl)))
  444.                       parents
  445.                       "\\|")
  446.                     "\\)")
  447.                        nil t)
  448.            (progn (setq prev-class (eif-set-case (buffer-substring
  449.                               (match-beginning 1)
  450.                               (match-end 1))))
  451.               (cons prev-class prev-feature-nm))
  452.          (beep)
  453.          (message
  454.           "(OO-Browser):  Internal error - no class associated with rename clause."))))))
  455.  
  456. (defun eif-to-feature-decl ()
  457.   (let ((end))
  458.     (while (and (progn (skip-chars-backward "^, \t\n")
  459.                (and (not (= (preceding-char) ?,))
  460.                 (not (looking-at "export[ \t\n]+"))))
  461.         (progn (skip-chars-backward " \t\n")
  462.                (setq end (point))
  463.                (beginning-of-line)
  464.                (if (search-forward "--" end t)
  465.                (progn (goto-char end)
  466.                   (skip-chars-forward " \t\n")
  467.                   nil)
  468.              (goto-char end)
  469.              t)))))
  470.   (if (looking-at "export[ \t\n]+")
  471.       (goto-char (match-end 0))
  472.     (skip-chars-forward " \t\n"))
  473.   (if (looking-at eif-feature-name)
  474.       (buffer-substring (match-beginning 0) (match-end 0))))
  475.  
  476.  
  477. ;; ************************************************************************
  478. ;; Private variables
  479. ;; ************************************************************************
  480.  
  481. (defconst eif-feature-name
  482.   (concat 
  483.    "\\("
  484.    "\\(prefix[ \t]+\"\\(not\\|\\+\\|-\\)\"\\)"
  485.    "\\|infix[ \t]+\"\\(div\\|mod\\|^\\|<=?\\|>=?\\|\+\\|-\\|\\*\\|/"
  486.                    "\\|and then\\|and\\|or else\\|or\\|xor\\|implies\\)"
  487.    "\\|" eif-identifier "\\)")
  488.   "Regexp matching any Eiffel feature name.
  489. Will also match class names and keywords, so tests for these should precede
  490. use of this expression.")
  491.  
  492. (defconst eif-export-key-regexp
  493.   "\\(^[ \t]*\\|[ \t]+\\)export[ \t\n]+"
  494.   "Regexp matching the Eiffel export keyword in context.")
  495.  
  496. (defconst eif-class-repeat (concat "repeat[ \t]+" eif-identifier)
  497.   "Match to an Eiffel 'repeat <class>' phrase.  Grouping 1 is class name.")
  498.  
  499. (defconst eif-exported-feature
  500.   (concat "\\(,\\|export[ \t\n]+\\(--.*[ \t\n]+\\)*\\)"
  501.       eif-feature-name "\\([ \t]*{[^}]+}\\)?"
  502.       "\\([ \t]*[\n,]\\|[ \t]+--\\)")
  503.   "Regexp to match to a feature declaration in an export clause.
  504.   Exclude 'repeat <class>' phrases.  Feature name is grouping 3.")
  505.  
  506.  
  507. (provide 'br-eif-ft)
  508.